home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / rts / recnum.scm < prev    next >
Text File  |  1995-10-13  |  4KB  |  118 lines
  1. ; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.
  2.  
  3. ; Rectangular complex arithmetic built on real arithmetic.
  4.  
  5. (define-extended-number-type :recnum (:complex)
  6.   (make-recnum real imag)
  7.   recnum?
  8.   (real recnum-real-part)
  9.   (imag recnum-imag-part))
  10.  
  11. (define (rectangulate x y)    ; Assumes (eq? (exact? x) (exact? y))
  12.   (if (= y 0)
  13.       x
  14.       (make-recnum x y)))
  15.  
  16. (define (rectangular-real-part z)
  17.   (if (recnum? z)
  18.       (recnum-real-part z)
  19.       (real-part z)))
  20.  
  21. (define (rectangular-imag-part z)
  22.   (if (recnum? z)
  23.       (recnum-imag-part z)
  24.       (imag-part z)))
  25.  
  26. (define (rectangular+ a b)
  27.   (rectangulate (+ (rectangular-real-part a) (rectangular-real-part b))
  28.         (+ (rectangular-imag-part a) (rectangular-imag-part b))))
  29.  
  30. (define (rectangular- a b)
  31.   (rectangulate (- (rectangular-real-part a) (rectangular-real-part b))
  32.         (- (rectangular-imag-part a) (rectangular-imag-part b))))
  33.  
  34. (define (rectangular* a b)
  35.   (let ((a1 (rectangular-real-part a))
  36.     (a2 (rectangular-imag-part a))
  37.     (b1 (rectangular-real-part b))
  38.     (b2 (rectangular-imag-part b)))
  39.     (rectangulate (- (* a1 b1) (* a2 b2))
  40.           (+ (* a1 b2) (* a2 b1)))))
  41.  
  42. (define (rectangular/ a b)
  43.   (let ((a1 (rectangular-real-part a))
  44.     (a2 (rectangular-imag-part a))
  45.     (b1 (rectangular-real-part b))
  46.     (b2 (rectangular-imag-part b)))
  47.     (let ((d (+ (* b1 b1) (* b2 b2))))
  48.       (rectangulate (/ (+ (* a1 b1) (* a2 b2)) d)
  49.             (/ (- (* a2 b1) (* a1 b2)) d)))))
  50.  
  51. (define (rectangular= a b)
  52.   (let ((a1 (rectangular-real-part a))
  53.     (a2 (rectangular-imag-part a))
  54.     (b1 (rectangular-real-part b))
  55.     (b2 (rectangular-imag-part b)))
  56.     (and (= a1 b1) (= a2 b2))))
  57.  
  58.  
  59. ; Methods
  60.  
  61. (define-method &complex? ((z :recnum)) #t)
  62.  
  63. (define-method &real-part ((z :recnum)) (recnum-real-part z))
  64. (define-method &imag-part ((z :recnum)) (recnum-imag-part z))
  65.  
  66. ; Methods on complexes in terms of real-part and imag-part
  67.  
  68. (define-method &exact? ((z :recnum))
  69.   (exact? (recnum-real-part z)))
  70.  
  71. (define-method &inexact->exact ((z :recnum))
  72.   (make-recnum (inexact->exact (recnum-real-part z))
  73.            (inexact->exact (recnum-imag-part z))))
  74.  
  75. (define-method &exact->inexact ((z :recnum))
  76.   (make-recnum (exact->inexact (recnum-real-part z))
  77.            (exact->inexact (recnum-imag-part z))))
  78.  
  79. (define (define-recnum-method mtable proc)
  80.   (define-method mtable ((m :recnum) (n :complex)) (proc m n))
  81.   (define-method mtable ((m :complex) (n :recnum)) (proc m n)))
  82.  
  83. (define-recnum-method &+ rectangular+)
  84. (define-recnum-method &- rectangular-)
  85. (define-recnum-method &* rectangular*)
  86. (define-recnum-method &/ rectangular/)
  87. (define-recnum-method &= rectangular=)
  88.  
  89. (define-method &sqrt ((n :real))
  90.   (if (< n 0)
  91.       (make-rectangular 0 (sqrt (- 0 n)))
  92.       (next-method)))            ; not that we have to
  93.  
  94. ; Gleep!  Can we do quotient and remainder on Gaussian integers?
  95. ; Can we do numerator and denominator on complex rationals?
  96.  
  97. (define-method &number->string ((z :recnum) radix)
  98.   (let ((x (real-part z))
  99.     (y (imag-part z)))
  100.     (let ((r (number->string x radix))
  101.       (i (number->string (abs y) radix))
  102.       (& (if (< y 0) "-" "+")))
  103.       (if (and (inexact? y)        ;gross
  104.            (char=? (string-ref i 0) #\#))
  105.       (string-append (if (char=? (string-ref r 0) #\#)
  106.                  ""
  107.                  "#i")
  108.              r &
  109.              (substring i 2 (string-length i))
  110.              "i")
  111.       (string-append r & i "i")))))
  112.  
  113. (define-method &make-rectangular ((x :real) (y :real))
  114.   (if (eq? (exact? x) (exact? y))
  115.       (rectangulate x y)
  116.       (rectangulate (if (exact? x) (exact->inexact x) x)
  117.             (if (exact? y) (exact->inexact y) y))))
  118.